home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / mformt.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  6.5 KB  |  216 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module mformt)
  13. (load-macsyma-macros mforma)
  14.  
  15. (EVAL-WHEN (EVAL)
  16.        (SETQ MACRO-EXPANSION-USE 'DISPLACE))
  17.  
  18.  
  19. #+lispm
  20. (record-source-file-name 'mformat-loop 'macro t)
  21. ;;macro expand the following!!
  22.  
  23. (DEF-MFORMAT)
  24. ;;macro expansion of the (def-mformat)  --wfs
  25. ;(PROGN 'COMPILE
  26. ;       (DEFMACRO DEF-MFORMAT-OP (CHAR &REST BODY)
  27. ;           `(+DEF-MFORMAT-OP || ,CHAR . ,BODY))
  28. ;       (DEFMACRO DEF-MFORMAT-VAR (VAR VAL INIT)
  29. ;           `(+DEF-MFORMAT-VAR || ,VAR ,VAL ,INIT))
  30. ;       (DEFMACRO MFORMAT-LOOP (&REST ENDCODE)
  31. ;           `(+MFORMAT-LOOP || . ,ENDCODE)))
  32. #+lispm
  33. (record-source-file-name 'def-format-var 'defmacro t)
  34. ;;see above-wfs
  35.  
  36.  
  37. (DEF-MFORMAT-VAR |:-FLAG|     NIL T)
  38. (DEF-MFORMAT-VAR |@-FLAG|     NIL T)
  39. (DEF-MFORMAT-VAR PARAMETER   0  T) ; Who can read "~33,34,87A" ?
  40. (DEF-MFORMAT-VAR PARAMETER-P NIL T)
  41. (DEF-MFORMAT-VAR TEXT       NIL NIL)
  42. (DEF-MFORMAT-VAR TEXT-TEMP NIL NIL)
  43. (DEF-MFORMAT-VAR DISPLA-P NIL NIL)
  44. (DEF-MFORMAT-VAR PRE-%-P NIL NIL)
  45. (DEF-MFORMAT-VAR POST-%-P NIL NIL)
  46.  
  47. #-PDP10
  48. (DEFMFUN CHECK-OUT-OF-CORE-STRING (sstring) sstring)
  49.  
  50. (DEFMACRO PUSH-TEXT-TEMP ()
  51.       '(IF TEXT-TEMP (SETQ TEXT (CONS (CONS '(TEXT-STRING) (NREVERSE TEXT-TEMP))
  52.                       TEXT)
  53.                    TEXT-TEMP NIL)))
  54.  
  55. (DEFMACRO OUTPUT-TEXT ()
  56.       '(PROGN (PUSH-TEXT-TEMP)
  57.           (OUTPUT-TEXT* STREAM TEXT DISPLA-P PRE-%-P POST-%-P)
  58.           (SETQ TEXT NIL DISPLA-P NIL PRE-%-P NIL POST-%-P NIL)))
  59.  
  60. (DEF-MFORMAT-OP (#\% #\&)
  61.         (COND ((OR TEXT TEXT-TEMP)
  62.                (SETQ POST-%-P T)
  63.                ;; there is text to output.
  64.                (OUTPUT-TEXT))
  65.               (T
  66.                (SETQ PRE-%-P T))))
  67.  
  68. (DEF-MFORMAT-OP #\M
  69.         (PUSH-TEXT-TEMP)
  70.         (LET ((ARG (POP-MFORMAT-ARG)))
  71.              (AND @-FLAG (ATOM ARG) 
  72.               (SETQ ARG (OR (GET ARG 'OP) ARG)))
  73.              (COND (|:-FLAG|
  74.                 (PUSH (CONS '(TEXT-STRING) (MSTRING ARG)) TEXT))
  75.                (T
  76.                 (SETQ DISPLA-P T)
  77.                 (PUSH ARG TEXT)))))
  78.  
  79. (DEF-MFORMAT-OP #\A
  80.         (PUSH-TEXT-TEMP)
  81.         (PUSH (CONS '(TEXT-STRING) (EXPLODEN (POP-MFORMAT-ARG))) TEXT))
  82.  
  83. (DEF-MFORMAT-OP #\S
  84.         (PUSH-TEXT-TEMP)
  85.         (PUSH (CONS '(TEXT-STRING)
  86.                 (MAPL #'(LAMBDA (C)
  87.                        (RPLACA C (GETCHARN (CAR C) 1)))
  88.                  (EXPLODE (POP-MFORMAT-ARG))))
  89.               TEXT))
  90.  
  91. (DEFMFUN MFORMAT N
  92.   (OR (> N 1)
  93.       ;; make error message without new symbols.
  94.       ;; This error should not happen in compiled code because
  95.       ;; this check is done at compile time too.
  96.       (MAXIMA-ERROR 'WRNG-NO-ARGS 'MFORMAT))
  97.   (LET* ((STREAM (ARG 1))
  98.      (sSTRING (exploden (check-out-of-core-string (ARG 2))))
  99.      (arg-index 2))
  100.     ;(or (eql (car sstring) #\&) (push #\& sstring))
  101.     
  102.     #+NIL
  103.     (AND (OR (NULL STREAM)
  104.          (EQ T STREAM))
  105.      (SETQ STREAM *standard-output*))
  106.     ;; This is all done via macros to save space,
  107.     ;; (No functions, no special variable symbols.)
  108.     ;; If the lack of flexibilty becomes an issue then
  109.     ;; it can be changed easily.
  110.     (MFORMAT-LOOP (OUTPUT-TEXT))
  111.     ;; On Multics keep from getting bitten by line buffering.
  112.     #+Multics
  113.     (FORCE-OUTPUT STREAM)
  114.     ))
  115.  
  116. ;;can't change mformat since there are various places where stream = nil means
  117. ;; standard output not a string  
  118. ;;note: compile whole file, incremental compiling will not work.
  119.  
  120.  
  121. (DEFMFUN aFORMAT N
  122.   (OR (> N 1)
  123.       ;; make error message without new symbols.
  124.       ;; This error should not happen in compiled code because
  125.       ;; this check is done at compile time too.
  126.       (MAXIMA-ERROR 'WRNG-NO-ARGS 'MFORMAT))
  127.   (LET ((STREAM (ARG 1))
  128.     (sSTRING (exploden (check-out-of-core-string (ARG 2))))
  129.     (arg-index 2))
  130.     #+NIL
  131.     (AND (OR (NULL STREAM)
  132.          (EQ T STREAM))
  133.      (SETQ STREAM *standard-output*))
  134.  
  135.     (cond((null stream)
  136.       (with-output-to-string (stream)
  137.         (mformat-loop (output-text))))
  138.      (t (mformat-loop (output-text))))
  139.     ;; This is all done via macros to save space,
  140.     ;; (No functions, no special variable symbols.)
  141.     ;; If the lack of flexibilty becomes an issue then
  142.     ;; it can be changed easily.
  143.     #+Multics
  144.     (FORCE-OUTPUT STREAM)
  145.     ))
  146.  
  147.  
  148. (DEFUN OUTPUT-TEXT* (STREAM TEXT DISPLA-P PRE-%-P POST-%-P)
  149.   (SETQ TEXT (NREVERSE TEXT))
  150.   ;; outputs a META-LINE of text.
  151.   (COND (DISPLA-P (DISPLAF (CONS '(MTEXT) TEXT) STREAM))
  152.     (T
  153.      (IF PRE-%-P (TERPRI STREAM))
  154.      (DO ()
  155.          ((NULL TEXT))
  156.        (DO ((L (CDR (POP TEXT)) (CDR L)))
  157.            ((NULL L))
  158.          (TYO (CAR L) STREAM)))
  159.      (IF POST-%-P (TERPRI STREAM)))))
  160.  
  161. (DEFUN-prop (TEXT-STRING DIMENSION) (FORM RESULT)
  162.   ;; come up with something more efficient later.
  163.   (DIMENSION-ATOM (MAKNAM (CDR FORM)) RESULT))
  164.  
  165. (DEFMFUN DISPLAF (OBJECT STREAM)
  166.   ;; for DISPLA to a file. actually this works for SFA's and
  167.   ;; other streams in maclisp.
  168.   #-(or cl NIL)
  169.   (IF (EQ STREAM NIL)
  170.       (DISPLA OBJECT)
  171.       (LET ((|^R| T)
  172.         (|^W| T)
  173.          (OUTFILES (NCONS STREAM))
  174.         )
  175.     (DISPLA OBJECT)))
  176.   #+(or cl NIL)
  177.   ;; a bit of a kludge here. ^R and ^W still communicate something
  178.   ;; to the displa package, but OUTFILES has not been implemented/hacked.
  179.   (IF (OR (EQ STREAM NIL)
  180.       (EQ STREAM *standard-output*))
  181.       (DISPLA OBJECT)
  182.     (LET ((*standard-output* STREAM)
  183.       (|^R| T)
  184.       (|^W| T))
  185.      (DISPLA OBJECT))))
  186.  
  187. (DEFMFUN MTELL (&REST L)
  188.   (APPLY #'MFORMAT NIL L))
  189.  
  190.  
  191. ;; Calling-sequence optimizations.
  192. #+PDP10
  193. (PROGN 'COMPILE
  194.        (LET ((X (GETL 'MFORMAT '(EXPR LSUBR))))
  195.      (REMPROP '*MFORMAT (CAR X))
  196.      (PUTPROP '*MFORMAT (CADR X) (CAR X)))
  197.        (DECLARE (*LEXPR *MFORMAT))
  198.        (DEFMFUN *MFORMAT-2 (A B) (*MFORMAT A B))
  199.        (DEFMFUN *MFORMAT-3 (A B C) (*MFORMAT A B C))
  200.        (DEFMFUN *MFORMAT-4 (A B C D) (*MFORMAT A B C D))
  201.        (DEFMFUN *MFORMAT-5 (A B C D E) (*MFORMAT A B C D E))
  202.  
  203.        (LET ((X (GETL 'MTELL '(EXPR LSUBR))))
  204.      (REMPROP '*MTELL (CAR X))
  205.      (PUTPROP '*MTELL (CADR X) (CAR X)))
  206.        (DECLARE (*LEXPR *MTELL))
  207.        (DEFMFUN MTELL1 (A)         (*MTELL A))
  208.        (DEFMFUN MTELL2 (A B)       (*MTELL A B))
  209.        (DEFMFUN MTELL3 (A B C)     (*MTELL A B C))
  210.        (DEFMFUN MTELL4 (A B C D)   (*MTELL A B C D))
  211.        (DEFMFUN MTELL5 (A B C D E) (*MTELL A B C D E))
  212.        )
  213.  
  214.  
  215.  
  216.